Language/OS - Multiplatform Resource Library/LANGUAGE OS.iso/scheme/boxer/boxer.lha/eval.lisp

Text File | 1993-07-17 | 26.7 KB | 717 lines

;-*- mode:lisp; package: Boxer;Base: 10.;  fonts: cptfont, cptfontb -*-

#|
            Copyright 1985 Massachusetts Institute of Technology

 Permission to use, copy, modify, distribute, and sell this software
 and its documentation for any purpose is hereby granted without fee,
 provided that the above copyright notice appear in all copies and that
 both that copyright notice and this permission notice appear in
 supporting documentation, and that the name of M.I.T. not be used in
 advertising or publicity pertaining to distribution of the software
 without specific, written prior permission.  M.I.T. makes no
 representations about the suitability of this software for any
 purpose.  It is provided "as is" without express or implied warranty.


                                         +-Data--+
                This file is part of the | BOXER | system
                                         +-------+

  This file contains the BOXER Evaluator.


|#

(DEFSUBST NAMED-BOX? (THING)
  (AND (BOX? THING) (NAME-ROW? (TELL THING :NAME-ROW))))

(COMPILER:MAKE-OBSOLETE NAMED-BOX-P "Use NAMED-BOX? instead")


;;;;;;;;;;;;;;;;;;;;;;;
;;;; Input Flavors ;;;;
;;;;;;;;;;;;;;;;;;;;;;;

(DEFINE-EVAL-MARKER FORCE-PORT-MARKER  :PORT-TO     :COERCE (PORTIFY BU:PORTIFY
                                     PORT-TO BU:PORT-TO) #\)
(DEFINE-EVAL-MARKER MAKE-NUMBER-MARKER :NUMBERIZE   :COERCE (NUMBERIZE BU:NUMBERIZE))
(DEFINE-EVAL-MARKER FORCE-DATA-MARKER  :DATAFY      :COERCE (DATAFY BU:DATAFY) #\')
(DEFINE-EVAL-MARKER FORCE-DOIT-MARKER  :DOITIFY     :COERCE (DOITIFY BU:DOITIFY))
(DEFINE-EVAL-MARKER DONT-PORT-MARKER   :DONT-PORT   :COERCE (DONT-PORT BU:DONT-PORT))
(DEFINE-EVAL-MARKER DONT-DATAFY-MARKER :DONT-DATAFY :COERCE (DONT-DATAFY BU:DONT-DATAFY))
(DEFINE-EVAL-MARKER BUILD-IT-MARKER    :BUILD       :COERCE (BUILD BU:BUILD))

;;; These are internal to the Evaluator and are used to handle things like named boxes and
;;; spaces (if they make it past the READER)
(DEFINE-EVAL-MARKER IGNORE-TOKEN-MARKER :IGNORE      :INTERNAL      (IGNORE))
(DEFINE-EVAL-MARKER DONT-IGNORE-MARKER  :DONT-IGNORE :INTERNAL (DONT-IGNORE))

;;; Various flavors of collection
;;; The vanilla flavored REST markers collect all of the remaining args on the line
;;; The delimited REST markers collect the args up to the next delimiter stopping at EOL
;;; the args can be collected into either a LIST (for internal use by the evaluator)
;;; or a BOX.  BOXER users should only use the Boxifying versions.  The Listifying versions
;;; exist only as an efficiency hack for Boxer primitives.

(DEFINE-EVAL-MARKER LIST-REST-MARKER :LIST-REST :COLLECT (LIST-REST BU:LIST-REST))
(DEFINE-EVAL-MARKER BOX-REST-MARKER  :BOX-REST  :COLLECT (BOX-REST BU:BOX-REST BU:REST) #\)
(DEFINE-EVAL-MARKER DELIM-LIST-REST-MARKER
            :DELIMITED-LIST-REST :COLLECT (DELIM-BOX-REST BU:DELIM-BOX-REST))
(DEFINE-EVAL-MARKER DELIM-BOX-REST-MARKER
            :DELIMITED-BOX-REST :COLLECT (DELIM-LIST-REST BU:DELIM-LIST-REST) #\
)

(DEFUN SAME-PNAME? (S1 S2)
  (STRING-EQUAL (GET-PNAME S1) (GET-PNAME S2)))

(DEFUN EVAL-SPECIAL-MARKER? (THING)
  (AND (SYMBOLP THING) (CONVERT-MARKER THING NIL)))



;;; Rules for Merging Markers
;;; When two markers refer to the same type of action (e.g. :DATAFY vs :DONT-DATAFY), the
;;; EXISTING-ACTION (which correspond to something which was typed by the User on the screen)
;;; always takes precedence over the NEW-ACTION (corresponding to the desired coercion in the
;;; arglist of the caller).
;;; When two markers are orthogonal, then they are grouped together in a list
;;; When merging list(s) each element must be checked for orthogonality

(DEFUN SAME-ACTION? (ACT1 ACT2)
  "Do the two special evaluator markers refer to the same type of action i.e. porting. "
  (EQ (GET ACT1 :ACTION-TYPE) (GET ACT2 :ACTION-TYPE)))

(DEFUN COMPONENT-ACTION? (ACT ACTS)
  (MEM #'SAME-ACTION? ACT ACTS))

(DEFUN DEL-ACTION (ACT ACTIONS)
  (DEL #'SAME-ACTION? ACT ACTIONS))

(DEFUN TRIM-ACTION-FROM-ACTIONS (ACTION ACTIONS)
  (COND ((AND (SYMBOLP ACTIONS) (SAME-ACTION? ACTION ACTIONS)) NIL)
    ((SYMBOLP ACTIONS) ACTIONS)
    (T (DEL-ACTION ACTION ACTIONS))))

(DEFUN CONVERT-MARKER (MARKER &OPTIONAL (SIGNAL-ERROR? T))
  "Converts an alias for a marker to the defined keyword symbol for that marker.
If the first arg is not a valid flavored input, then either an error is signalled
or NIL is returned depending upon the value of the second arg. "
  (OR (GET MARKER :BOXER-INPUT-FLAVOR)
      (AND SIGNAL-ERROR? (FERROR "~A is not a valid flavored input marker. " MARKER))))

(DEFUN CONVERT-ACTIONS (ACTIONS)
  (COND ((NULL ACTIONS) NIL)
    ((LISTP ACTIONS) (MAPCAR #'CONVERT-MARKER ACTIONS))
    (T (CONVERT-MARKER ACTIONS))))

(DEFUN MERGE-ACTION-MARKERS (EXISTING-ACTION NEW-ACTION)
  (COND ((NULL EXISTING-ACTION) NEW-ACTION)
    ((NULL NEW-ACTION) EXISTING-ACTION)
    ((OR (AND (SYMBOLP EXISTING-ACTION) (SYMBOLP NEW-ACTION)
          (SAME-ACTION? EXISTING-ACTION NEW-ACTION))
         (AND (LISTP EXISTING-ACTION) (SYMBOLP NEW-ACTION)
          (COMPONENT-ACTION? NEW-ACTION EXISTING-ACTION))
         (NULL NEW-ACTION))
     ;; if the NEW-ACTION refers to an already existing one, it does nothing
     EXISTING-ACTION)
    ((AND (SYMBOLP EXISTING-ACTION) (SYMBOLP NEW-ACTION))
     (LIST EXISTING-ACTION NEW-ACTION))
    ((AND (LISTP EXISTING-ACTION) (SYMBOLP NEW-ACTION))
     (NCONC EXISTING-ACTION (NCONS NEW-ACTION)))
    ((AND (SYMBOLP EXISTING-ACTION) (LISTP NEW-ACTION)
          (COMPONENT-ACTION? EXISTING-ACTION NEW-ACTION))
     (NCONC (NCONS EXISTING-ACTION) (DEL-ACTION EXISTING-ACTION NEW-ACTION)))
    ((AND (SYMBOLP EXISTING-ACTION) (LISTP NEW-ACTION))
     (NCONC (NCONS EXISTING-ACTION) NEW-ACTION))
    ((AND (LISTP EXISTING-ACTION) (LISTP NEW-ACTION))
     (DOLIST (EXIST EXISTING-ACTION)
       (SETQ NEW-ACTION (DEL-ACTION EXIST NEW-ACTION)))
     (NCONC EXISTING-ACTION NEW-ACTION))
    (T (FERROR "Bad format for existing action, ~A, or new action ~A"))))

(DEFUN COLLECT-AND-MERGE-ACTION-MARKERS (CURRENT-ACTION DESIRED-ACTIONS REST)
  (LOOP WITH FINAL-ACTIONS = (MERGE-ACTION-MARKERS (CONVERT-ACTIONS CURRENT-ACTION)
                           (CONVERT-ACTIONS DESIRED-ACTIONS))
    FOR EXP = REST THEN (CDR EXP)
    FOR TOKEN = (CAR EXP)
    UNTIL (NOT (EVAL-SPECIAL-MARKER? TOKEN))
    DO (SETQ FINAL-ACTIONS (MERGE-ACTION-MARKERS (CONVERT-ACTIONS TOKEN) FINAL-ACTIONS))
    WHEN (NULL EXP)
    DO (FERROR "The expression, ~A, seems to be only evaluator markers" REST)
    FINALLY
    (RETURN (VALUES EXP FINAL-ACTIONS))))



;;; SOme interface

;;; Lets get everything into the BOXER package for convenience
;;; Returns a symbol for the evaluator to dispatch on.
;;; EvBoxes are made transparent to the evaluator here by returning the correct token type
;;; For each type, there should be a (:PROPERTY <type> EVAL-HANDLER) defined which specifies
;;; what the evaluator is supposed to do when it encounters an object of type <type>

(DEFUN TOKEN-TYPE (TOKEN)
  (COND ((LABEL-PAIR? TOKEN) 'LABEL-PAIR)
    ((UNBOX-TOKEN? TOKEN) 'UNBOX-TOKEN)
    ((EVAL-IT-TOKEN? TOKEN) 'EVAL-TOKEN)
    ((NUMBERP TOKEN) 'NUMBER)
    ((ACCESS-PAIR? TOKEN) 'ACCESS-PAIR)    ;??????
    ((TURTLE? TOKEN) 'TURTLE)
    ((SPRITE-BOX? TOKEN) 'SPRITE-BOX)
    ((GRAPHICS-DATA-BOX? TOKEN) 'GRAPHICS-DATA-BOX)
    ((EVAL-SPECIAL-MARKER? TOKEN) 'SPECIAL-MARKER)
    ((FUNCTIONP TOKEN) 'PRIMITIVE)
    ((EVAL-DOIT? TOKEN) 'DOIT-BOX)
    ((EVAL-DATA? TOKEN) 'DATA-BOX)
    ((EVAL-PORT? TOKEN) 'PORT-BOX)
    ((SPACES?    TOKEN) 'SPACES)        ;just in case they happen to creep in
    (T (OR (CDR (ASSQ (TYPEP TOKEN)
              '((:SYMBOL . SYMBOL)
                (:LIST . LIST)
                (:CONS . LIST)
                (:STRING . STRING)
                (GRAPHICS-BOX . GRAPHICS-BOX))))
           (FERROR NIL "~S -- Unknown type in Evaluator." TOKEN)))))

(DEFUN BOX-HAS-INPUTS? (BOX)
  (MEMQ (GET-FIRST-ELEMENT BOX) *SYMBOLS-FOR-INPUT-LINE*))

(DEFUN GET-INPUT-ROW (BOX)
  (LET ((ROW (GET-FIRST-ROW BOX)))
    (WHEN (MEMQ (CAR ROW) *SYMBOLS-FOR-INPUT-LINE*)
      (CDR ROW))))

;;; to get an idea of what is being copied....
(DEFVAR *BOX-COPY-LIST* NIL)
(DEFVAR *BOX-COPY-COUNTER* 0)
(DEFMACRO WITH-COPYING-STATISTICS (&BODY BODY)
  `(PROGN (SETQ *BOX-COPY-LIST*    NIL
        *BOX-COPY-COUNTER* 0)
      . ,BODY))

(DEFUN SHOW-COPIES ()
  (FORMAT T "~%Number of Boxes copied: ~D~%Boxes copied: ~%~A"
      *BOX-COPY-COUNTER* *BOX-COPY-LIST*))

(DEFUN COPY-FOR-EVAL (THING)
  "The Evaluator copying function.  Copying is disabled/enabled by the variable
*EVALUATOR-COPYING-FUNCTION*.  Different copying strategies can be tested by setqing
the variable *EVALUATOR-COPYING-FUNCTION*. "
  (IF *EVALUATOR-COPYING-ON?*
      (FUNCALL *EVALUATOR-COPYING-FUNCTION* THING)
      THING))

(DEFUN MAKE-EVAL-BOX (STUFF)
  (MAKE-BOX STUFF))

(DEFSUBST BOXIFY (THING)
  (MAKE-EVDATA ROWS (IF (EVROW? THING) (NCONS THING) (NCONS (MAKE-EVROW-FROM-ENTRY THING)))))

;This subst takes a list of items and makes single-row evbox out of them.
(defsubst boxify-list (things)
  (make-evdata rows (ncons (make-evrow-from-entries things))))

(DEFSUBST MAKE-PORT-TO (BOX)
;(PORT-TO-FOR-EVAL BOX)                ;this makes a REAL Port instead
  (MAKE-EVPORT TARGET BOX))

(DEFUN DOITIFY (THING)
  (MAKE-EVDOIT ROWS (IF (OR (EVAL-BOX? THING)(EVAL-PORT? THING))(GET-BOX-ROWS THING)
            (NCONS (NCONS THING)))))



;; Each type of thing that the evaluator can see should have an EVAL-HANDLER property
;; which specifies the default behavior for that type of object.  This behavior can be
;; described by the evaluator's special markers and can be altered by passing a different
;; set of special markers to the EVAL-HANDLER procedure.
;; The EVAL-HANDLER should handle as many of the special evaluator marker as it wants to
;; and then it can pass the rest explicitly in another call to EV-THING or just ignore them

;; :RUN-THIS markers have to handled at the next higher level (RETURN-VALUE  ) because boxes
;; may have arguments that need to be bound

;; special markers return themselves
(DEFUN (:PROPERTY SPECIAL-MARKER EVAL-HANDLER) (MARKER &REST IGNORE)
  MARKER)

(DEFUN (:PROPERTY SPACES EVAL-HANDLER) (SPACES &REST IGNORE)
  SPACES)

(DEFUN (:PROPERTY LABEL-PAIR EVAL-HANDLER) (PAIR &OPTIONAL SPECIAL-ACTION)
  (EV-THING (LABEL-PAIR-ELEMENT PAIR) SPECIAL-ACTION))

(DEFUN (:PROPERTY SYMBOL EVAL-HANDLER) (SYMBOL SPECIAL-ACTION)
  (COND ((POINTS-TO-SELF SYMBOL) SYMBOL)
    ((FORCE-DATA-MARKER? SPECIAL-ACTION) (BOXIFY SYMBOL))
    (T (EV-THING (BOXER-SYMEVAL SYMBOL)
             (MERGE-ACTION-MARKERS SPECIAL-ACTION
               ;; will symeval to a named box !!
               DONT-IGNORE-MARKER)))))

(DEFUN (:PROPERTY PRIMITIVE EVAL-HANDLER) (PRIM &OPTIONAL SPECIAL-ACTION)
  ;; mostly error checking
  (COND ((FORCE-PORT-MARKER? SPECIAL-ACTION) (FERROR "Trying to port to a primitive"))
    ((FORCE-DATA-MARKER? SPECIAL-ACTION)
     (FERROR "Can't copy a primitive."))
    ((ZEROP (FUNCTION-NUMBER-OF-ARGS PRIM))
     (FUNCALL PRIM))
    (T PRIM)))

(DEFUN (:PROPERTY LIST EVAL-HANDLER) (LIST &OPTIONAL IGNORE)
  (EV-EXPRESSION LIST))

(DEFUN (:PROPERTY NUMBER EVAL-HANDLER) (NUMBER &REST IGNORE)
  NUMBER)

(DEFUN (:PROPERTY DOIT-BOX EVAL-HANDLER) (BOX &OPTIONAL SPECIAL-ACTION)
  (COND
    ;; first, we check for coerce actions
    ((FORCE-PORT-MARKER?  SPECIAL-ACTION)
     ;; let the box do it's stuff BEFORE porting
     (let ((result (run-it box)))
       (cond ((eval-box? result) (make-port-to result))
         ((eval-port? result) result)
         ((numberp result) (make-port-to (boxify result)))
         (t (ferror "Don't know how to port-to ~S" result)))))
    ((MAKE-NUMBER-MARKER? SPECIAL-ACTION) (NUMBERIZE (EV-THING BOX)))
    ((FORCE-DATA-MARKER?  SPECIAL-ACTION) (BOXIFY BOX))
    ((BUILD-IT-MARKER?    SPECIAL-ACTION) (BUILD-INTERNAL BOX))
    ((= 0 (FUNCTION-NUMBER-OF-ARGS BOX))
     ;; No arg doit boxes get executed right away
     (RUN-IT BOX))
    ;; finally, let the box do what it wants
    (T BOX)))

(DEFUN (:PROPERTY PORT-BOX EVAL-HANDLER) (PORT &OPTIONAL SPECIAL-ACTION)
  (COND
    ((MAKE-NUMBER-MARKER? SPECIAL-ACTION) (NUMBERIZE PORT))
    ((FORCE-DATA-MARKER?  SPECIAL-ACTION) (BOXIFY PORT))
    ((BUILD-IT-MARKER?    SPECIAL-ACTION)
     ;; perhaps this should be an error instead
     (BUILD-INTERNAL (GET-PORT-TARGET PORT)))
    (T PORT)))

(DEFUN (:PROPERTY DATA-BOX EVAL-HANDLER) (BOX SPECIAL-ACTION)
  (COND
    ;; first, we check for coerce actions
    ((FORCE-PORT-MARKER?  SPECIAL-ACTION) (MAKE-PORT-TO BOX))
    ((FORCE-DATA-MARKER?  SPECIAL-ACTION) (BOXIFY BOX))
    ((MAKE-NUMBER-MARKER? SPECIAL-ACTION) (NUMBERIZE BOX))
    ((FORCE-DOIT-MARKER?  SPECIAL-ACTION) (DOITIFY BOX))
    ((BUILD-IT-MARKER?    SPECIAL-ACTION) (BUILD-INTERNAL BOX))
    ;; finally, let the box do what it wants
    (T BOX)))

(DEFUN (:PROPERTY GRAPHICS-BOX EVAL-HANDLER) (BOX &OPTIONAL SPECIAL-ACTION)
  (COND
    ((FORCE-PORT-MARKER?  SPECIAL-ACTION) (MAKE-PORT-TO BOX))
    ((FORCE-DATA-MARKER?  SPECIAL-ACTION) (BOXIFY BOX))
    ((BUILD-IT-MARKER?    SPECIAL-ACTION)
     ;; perhaps this should be an error too...
     (BUILD-INTERNAL BOX))
    (T BOX)))

(DEFUN (:PROPERTY GRAPHICS-DATA-BOX EVAL-HANDLER) (BOX &OPTIONAL SPECIAL-ACTION)
  (COND
    ((FORCE-PORT-MARKER?  SPECIAL-ACTION) (MAKE-PORT-TO BOX))
    ((FORCE-DATA-MARKER?  SPECIAL-ACTION) (BOXIFY BOX))
    ((BUILD-IT-MARKER?    SPECIAL-ACTION) (BUILD-INTERNAL BOX))
    (T BOX)))

(DEFUN (:PROPERTY SPRITE-BOX EVAL-HANDLER) (BOX &OPTIONAL SPECIAL-ACTION)
  (COND
    ((FORCE-PORT-MARKER?  SPECIAL-ACTION) (MAKE-PORT-TO BOX))
    ((FORCE-DATA-MARKER?  SPECIAL-ACTION) (BOXIFY BOX))
    ((BUILD-IT-MARKER?    SPECIAL-ACTION) (BUILD-INTERNAL BOX))
    (T BOX)))

(DEFUN (:PROPERTY TURTLE EVAL-HANDLER) (OBJ &OPTIONAL IGNORE)
  OBJ)



;;; How to handle atsigns and excls at top level

;;;top level !'s are ignored
(DEFUN (:PROPERTY EVAL-TOKEN EVAL-HANDLER) (ET &OPTIONAL SPECIAL-ACTION)
  (EV-THING (EVAL-IT-TOKEN-ELEMENT ET) SPECIAL-ACTION))

(DEFUN (:PROPERTY UNBOX-TOKEN EVAL-HANDLER) (UT &OPTIONAL IGNORE)
  (LET ((THING-TO-UNBOX (EV-THING (UNBOX-TOKEN-ELEMENT UT))))
    (COND ((OR (EVAL-BOX? THING-TO-UNBOX) (NUMBERP THING-TO-UNBOX))
       (MAKE-UNBOX-PAIR THING-TO-UNBOX))
      ((eval-port? thing-to-unbox)        ;this is not quite right
       (make-unbox-pair (get-port-target thing-to-unbox)))
      ((UNBOX-PAIR? THING-TO-UNBOX)
       (MAKE-UNBOX-PAIR
         (EV-THING (GET-FIRST-ELEMENT (UNBOX-PAIR-ELEMENT THING-TO-UNBOX)))))
      (T
       (FERROR "~A was not a box.  You can only unbox boxes. " THING-TO-UNBOX)))))

;;; The result of EV-THING on an UNBOX-TOKEN will be an UNBOX-PAIR.  The two ar every similiar
;;; except that the unbox pair is guaranteed to have a box to unbox (or else an error would
;;; have been produced when we tried to make it

(DEFUN MAKE-UNBOX-PAIR (BOX)
  (CONS 'UNBOX-PAIR BOX))

(DEFSUBST UNBOX-PAIR? (X)
  (AND (LISTP X)
       (EQ (CAR X) 'UNBOX-PAIR)))

(DEFSUBST UNBOX-PAIR-ELEMENT (UP)
  (CDR UP))

;;; The Evaluator will call UNBOX-FUNCTION on an UNBOX-PAIR which
;;; returns a new expression to be passed to RETURN-VALUE which is the result of the unbox
;;; APPENDED to the rest of the expression AFTER the unbox

(DEFUN UNBOX-FUNCTION (TOKEN EXPRESSION)
  (LET ((ROWS (GET-BOX-ROWS (UNBOX-PAIR-ELEMENT TOKEN))))
    (SELECTQ *MULTIPLE-ROW-TOP-LEVEL-UNBOX-ACTION*
      ((:FLATTEN) (APPEND (LEXPR-FUNCALL #'APPEND ROWS) EXPRESSION))
      ((:TRUNCATE) (APPEND (CAR ROWS) EXPRESSION))
      ((:ERROR)
       (IF (= (LENGTH ROWS) 1) (APPEND (CAR ROWS) EXPRESSION)
       (FERROR "The box,~A, has more than one row."
           (UNBOX-PAIR-ELEMENT TOKEN)))))))



;;; Infix declarations

(DEFPROP BU:^ 140 :INFIX-PRECEDENCE)
(DEFPROP BU:* 120 :INFIX-PRECEDENCE)
(DEFPROP BU:// 120 :INFIX-PRECEDENCE)
(DEFPROP BU:+ 100 :INFIX-PRECEDENCE)
(DEFPROP BU:- 100 :INFIX-PRECEDENCE)
(DEFPROP BU:> 80 :INFIX-PRECEDENCE)
(DEFPROP BU:< 80 :INFIX-PRECEDENCE)
(DEFPROP BU: 80 :INFIX-PRECEDENCE)
(DEFPROP BU: 80 :INFIX-PRECEDENCE)
(DEFPROP BU:>= 80 :INFIX-PRECEDENCE)
(DEFPROP BU:<= 80 :INFIX-PRECEDENCE)
(DEFPROP BU:= 80 :INFIX-PRECEDENCE)
(DEFPROP BU: 80 :INFIX-PRECEDENCE)



;;same as in EVAL
(DEFUN BOXER-FUNCTION? (THING)
  (OR (EVAL-DOIT? THING) (FUNCTIONP THING)
      (AND (EVAL-PORT? THING) (EVAL-DOIT? (GET-PORT-TARGET THING)))))

(DEFSUBST APPLY-IT? (CURRENT-TOKEN SPECIAL-ACTION)
  (OR (AND (BOXER-FUNCTION? CURRENT-TOKEN)
       (NOT (OR (FORCE-DATA-MARKER? SPECIAL-ACTION))))
      (FORCE-DOIT-MARKER? SPECIAL-ACTION)))

(DEFSUBST RUN-IT? (CURRENT-TOKEN SPECIAL-ACTION)
  (OR (AND (BOXER-FUNCTION? CURRENT-TOKEN)
       (NOT (FORCE-DATA-MARKER? SPECIAL-ACTION))
       (= 0 (FUNCTION-NUMBER-OF-ARGS CURRENT-TOKEN)))
      (AND (FORCE-DOIT-MARKER? SPECIAL-ACTION)
       (= 0 (FUNCTION-NUMBER-OF-ARGS CURRENT-TOKEN)))))

(DEFSUBST IGNORE-IT? (CURRENT-TOKEN SPECIAL-ACTION)
  ;; get rid of junk like named boxes here.
  (OR (IGNORE-TOKEN-MARKER? SPECIAL-ACTION)
      (AND (EVAL-NAMED? CURRENT-TOKEN)
       (NOT (DONT-IGNORE-MARKER? SPECIAL-ACTION)))))

(DEFSUBST IGNORE-MARKER? (THING)
  (OR (EQ THING :IGNORE-CURRENT-TOKEN) (SPACES? THING)))

(DEFSUBST UNBOX-IT? (THING)
  (EQ THING *UNBOX-MARKER*))

;;; Space handling grossness.  This will eventually have to fixed somehwere else BEFORE the
;;; evaluator gets hold of a form
(DEFSUBST GET-NEXT-MEANINGFUL-THING (EXP)
  (LOOP FOR THING IN EXP
    FOR INDEX = 0 THEN (INCF INDEX)
    UNLESS (IGNORE-MARKER? THING)
      RETURN (VALUES THING (NTHCDR (1+ INDEX) EXP))))

;;; EV-THING has to check for objects to be ignored (like named boxes) since
;;; unlike, RETURN-VALUE, it looks at the raw uncoerced objects
(DEFUN EV-THING (THING &OPTIONAL SPECIAL-ACTION)
  (LET* ((THING-TYPE (TOKEN-TYPE THING))
     (WHAT-TO-DO (GET THING-TYPE 'EVAL-HANDLER))
     (CANONICAL-ACTION (AND SPECIAL-ACTION (CONVERT-ACTIONS SPECIAL-ACTION))))
    (COND ((NULL WHAT-TO-DO) (FERROR "Don't know how to evaluate ~A" THING))
      ((IGNORE-IT? THING CANONICAL-ACTION) :IGNORE-CURRENT-TOKEN)
      (T (FUNCALL WHAT-TO-DO THING CANONICAL-ACTION)))))

(DEFUN RETURN-VALUE (EXPRESSION &OPTIONAL SPECIAL-ACTION OLD-INFIX-LEVEL COPYING-FUNCTION)
  (LET ((F (EV-THING (CAR EXPRESSION) SPECIAL-ACTION))
    ;; we need to process @'s before this !!!
    (NEW-INFIX-LEVEL (WHEN (SYMBOLP (GET-NEXT-MEANINGFUL-THING (CDR EXPRESSION)))
               (GET (GET-NEXT-MEANINGFUL-THING (CDR EXPRESSION))
                :INFIX-PRECEDENCE)))
    (*EVALUATOR-COPYING-FUNCTION* (OR COPYING-FUNCTION #'SHALLOW-COPY-FOR-EVALUATOR)))
      (COND ((UNBOX-PAIR? F)
         ;; Decide where SPECIAL-ACTION is supposed to be !!!!
         (RETURN-VALUE (UNBOX-FUNCTION F (CDR EXPRESSION)) SPECIAL-ACTION))
        ((EVAL-SPECIAL-MARKER? F)
         (MULTIPLE-VALUE-BIND (EXP NEW-ACTIONS)
         (COLLECT-AND-MERGE-ACTION-MARKERS F SPECIAL-ACTION (CDR EXPRESSION))
           (RETURN-VALUE EXP NEW-ACTIONS)))
        ((IGNORE-MARKER? F)
         (RETURN-VALUE (CDR EXPRESSION) SPECIAL-ACTION OLD-INFIX-LEVEL))
        ((APPLY-IT? F SPECIAL-ACTION)
         (MULTIPLE-VALUE-BIND (ARGS REST)
         (COLLECT-ARGS F (CDR EXPRESSION))
           (VALUES (BOXER-APPLY F ARGS) REST)))
        ((AND (NOT-NULL NEW-INFIX-LEVEL)
          (OR (NULL OLD-INFIX-LEVEL) (> NEW-INFIX-LEVEL OLD-INFIX-LEVEL)))
         (MULTIPLE-VALUE-BIND (THING AFTER-THING)
         (GET-NEXT-MEANINGFUL-THING (CDR EXPRESSION))
           (RETURN-VALUE (INFIX-EXPRESSION-SMOOSH (EV-THING THING NIL) (COPY-FOR-EVAL F)
                              AFTER-THING NEW-INFIX-LEVEL))))
        (T
         ;;; **** WARNING ****
         ;;; I took out a (COPY-FOR-EVAL F) here
         (VALUES F (CDR EXPRESSION))))))

(DEFUN EV-EXPRESSION (EXPRESSION &OPTIONAL ACTIONS)
  (MULTIPLE-VALUE-BIND (RESULT REST)
      (RETURN-VALUE EXPRESSION ACTIONS)
    (IF (NULL REST)
    RESULT
    (EV-EXPRESSION REST))))

(DEFUN EVAL-BOX-ROWS (BOX)
  (IF (NUMBERP BOX)
      BOX
      (LOOP WITH RESULT = NIL
        FOR ROW IN (GET-BOX-ROWS-FOR-EVAL BOX)
        UNLESS (NULL ROW)
          DO (SETQ RESULT (EV-EXPRESSION ROW))
        FINALLY
          (RETURN RESULT))))

(DEFUN INFIX-EXPRESSION-SMOOSH (FUN ARG1 EXP PRECEDENCE)
  (MULTIPLE-VALUE-BIND (ARG2 REST)
      (RETURN-VALUE EXP NIL PRECEDENCE)
    (APPEND (NCONS (BOXER-APPLY FUN `(,ARG1 ,ARG2))) REST)))



;;; Stuff used to handle (flavored) arglists

(DEFUN BOX-ARGLIST (BOX)            ;returns the raw arglist
  (mapcar #'(LAMBDA (entry)
          (if (label-pair? entry)
          (label-pair-label entry)
          entry))
      (GET-INPUT-ROW box)))

(DEFUN GET-ARG-TEMPLATE-FROM-ITEM (ARG-TEMPLATE)
  (COND ((LISTP ARG-TEMPLATE)
     (LET ((ITEM (PARSE-LIST-FOR-EVAL ARG-TEMPLATE)))
       (MAPCAR #'CONVERT-MARKER (FIRSTN (1- (LENGTH ITEM)) ITEM))))
    (T NIL)))

(DEFSUBST GET-TEMPLATE-FROM-ARGLIST (ARGLIST)
  (WHEN (FLAVORED-ARGLIST? ARGLIST)        ;otherwise No special handling
    (LOOP FOR ITEM IN ARGLIST
      UNLESS (SPACES? ITEM)
        COLLECTING (GET-ARG-TEMPLATE-FROM-ITEM ITEM))))

(DEFSUBST GET-ARG-NAME-FROM-ITEM (ITEM)
  (COND ((LISTP ITEM) (CAR (LAST ITEM)))
    (T ITEM)))

(DEFSUBST GET-ARG-NAMES-FROM-ARGLIST (ARGLIST);parses out just the names in a flavored arglist
  (MAPCAR #'GET-ARG-NAME-FROM-ITEM ARGLIST))

;; for lisp functions...

(DEFUN GET-ARGS-TEMPLATE (FUN)
  (SEND *FUNNY-FUNCTION-ARGLIST-TABLE* :GET-HASH FUN))

(DEFUN REMOVE-ARGS-TEMPLATE (FUN)
  (SEND *FUNNY-FUNCTION-ARGLIST-TABLE* :REM-HASH FUN))

(DEFUN SET-ARGS-TEMPLATE (FUN TEMPLATE)
    (SEND *FUNNY-FUNCTION-ARGLIST-TABLE* :PUT-HASH FUN TEMPLATE))

;;; these are the top level functions which should be called to get info about
;;; a function's arglist

(DEFUN GET-TEMPLATE (FUN)
  (IF (FUNCTIONP FUN) (GET-ARGS-TEMPLATE FUN)
      (GET-TEMPLATE-FROM-ARGLIST (BOX-ARGLIST FUN))))

(DEFUN GET-ARG-NAMES (FUN)
  (IF (FUNCTIONP FUN) (ARGLIST FUN)
      (GET-ARG-NAMES-FROM-ARGLIST (BOX-ARGLIST FUN))))

(DEFUN FUNCTION-NUMBER-OF-ARGS (FUNCTION)
  (COND ((EVAL-BOX? FUNCTION) (LENGTH (BOX-ARGLIST FUNCTION)))
    ((EVAL-PORT? FUNCTION) (LENGTH (BOX-ARGLIST (GET-PORT-TARGET FUNCTION))))
    (T (ldb %%arg-desc-min-args (boxer-args-info FUNCTION)))))

(DEFUN COLLECT-ARGS (FUN EXPRESSION)
  (DECLARE (VALUES COLLECTED-ARGS REMAINING-EXPRESSION))
  (LOOP WITH TEMPLATE = (GET-TEMPLATE FUN)
    FOR INDEX FROM 0 TO (1- (FUNCTION-NUMBER-OF-ARGS FUN))
    FOR ARG-TEMP = (NTH INDEX TEMPLATE)
    COLLECT
      (COND ((COLLECT-MARKER? ARG-TEMP)
         (MULTIPLE-VALUE-BIND (RESULT REST)
             (COLLECT-REST-ARGS EXPRESSION ARG-TEMP)
           (SETQ EXPRESSION REST)
           RESULT))
        ;;; ***WARNING ****
        ;;; putting in copying here after removing it from return-value
        ((NOT (NULL EXPRESSION))
         ;; we use this crock to insure that numbers are put into the stack
         ;; frames as BOXes which can be CHANGEd.  Since primitives will
         ;; generally prefer numbers (or ports), this kind of copying only
         ;; applies for DOIT-BOXes
;         (MULTIPLE-VALUE-BIND (RESULT REST)
;             (RETURN-VALUE EXPRESSION ARG-TEMP NIL (IF (FUNCTIONP FUN)
;                                   #'SHALLOW-COPY-FOR-EVALUATOR
;                                   #'SHALLOW-COPY-FOR-ARGLIST))
;           (SETQ EXPRESSION REST)
;           RESULT)
         (MULTIPLE-VALUE-BIND (RESULT REST)
             (RETURN-VALUE EXPRESSION ARG-TEMP NIL)
           (SETQ EXPRESSION REST)
           (let ((*evaluator-copying-function* (IF (FUNCTIONP FUN)
                                   #'SHALLOW-COPY-FOR-EVALUATOR
                                   #'SHALLOW-COPY-FOR-ARGLIST)))
             (copy-for-eval RESULT))))
        (T (FERROR "The function ~A needs more inputs"
               (IF (BOX? FUN) (TELL FUN :NAME) FUN))))
      INTO ARGS
    FINALLY
      (RETURN (VALUES ARGS EXPRESSION))))

;;; Use this for Boxer's version of &REST arguments
(DEFSUBST COLLECT-MARKER? (THING)    ;should probably trim the number of collection styles
  (OR (BOX-REST-MARKER?  THING)
      (LIST-REST-MARKER? THING)
      (DELIM-BOX-REST-MARKER?  THING)
      (DELIM-LIST-REST-MARKER? THING)))

(DEFSUBST DELIMITED-COLLECTION? (MARKER)
  (OR (DELIM-BOX-REST-MARKER?  MARKER)
      (DELIM-LIST-REST-MARKER? MARKER)))

(DEFSUBST BOXED-COLLECTION? (MARKER)
  (OR (BOX-REST-MARKER? MARKER)
      (DELIM-BOX-REST-MARKER? MARKER)))

;;; this need to hack ports when/if we figure out what port-collect means...
;;; also, should this be copying the collected args ?
(DEFUN COLLECT-REST-ARGS (EXPRESSION ARG-TEMP)
  (DECLARE (VALUES COLLECTED-ARGS REMAINING-EXPRESSION))
  (MULTIPLE-VALUE-BIND (COLLECTED-ARGS REST)
      (IF (DELIMITED-COLLECTION? ARG-TEMP) (COLLECT-UNTIL-DELIMITER EXPRESSION)
      (VALUES EXPRESSION NIL))
    ;; perhaps do something (copy? port?) to the collected args here...
    (IF (BOXED-COLLECTION? ARG-TEMP)
    (VALUES (MAKE-EVDATA ROWS (NCONS (MAKE-EVROW-FROM-ENTRIES COLLECTED-ARGS))) REST)
    (VALUES COLLECTED-ARGS REST))))


;; this doesn't work right.  Needs to be more selective as to what a delimiter is...
;; also doesn't allow for labels in the collected args....
(DEFUN COLLECT-UNTIL-DELIMITER (EXP)
  (LOOP FOR ITEM IN EXP
    FOR INDEX = 0 THEN (INCF INDEX)
    WHEN (LABEL-PAIR? ITEM)
      RETURN (VALUES (FIRSTN INDEX EXP) (NTHCDR INDEX EXP))
    FINALLY
      (RETURN (VALUES EXP NIL))))



;;;; APPLY

(DEFUN BOXER-APPLY-PRIMITIVE (PRIM ARGS)
  (APPLY PRIM ARGS))

;; calls read on a box if it has to if it is an EVbox just returns the rows
(DEFUN GET-BOX-ROWS-FOR-EVAL (BOX)
  (IF (BOX-HAS-INPUTS? BOX) (CDR (GET-BOX-ROWS BOX))
      (GET-BOX-ROWS BOX)))

(DEFSUBST DYNAMIC-CALL? (FUN)
  ;; needs to check for copying (dynamic)  or porting (lexical)
  (NOT (EVAL-PORT? FUN)))

(DEFSUBST GET-LEXICAL-ROOT (FUN)
  (COND ((EVAL-PORT? FUN)(GET-PORT-TARGET FUN))
    ((BOX? FUN) FUN)
    ((evbox? fun) fun)
    (T (FERROR "don't know how to get the lexical root of ~A" FUN))))

(DEFUN BOXER-APPLY (FUN ARGS)
  (LET ((*CURRENT-FUNCTION-BEING-FUNCALLED* FUN))
    (COND ((FUNCTIONP FUN) (BOXER-APPLY-PRIMITIVE FUN ARGS))
      ((DYNAMIC-CALL? FUN)
       ;; must be a box that has been copied so we build up the stack
       (WITH-DYNAMIC-VALUES-BOUND (MAKE-FRAME FUN ARGS)
         (EVAL-BOX-ROWS FUN)))
      (T
       ;; must be a port i.e. lexical scoping
       ;; don't pass the stack and change the static root
       (WITH-STATIC-ROOT-BOUND (GET-LEXICAL-ROOT FUN)
         (WITH-NEW-DYNAMIC-VALUES (MAKE-FRAME FUN ARGS)
           (EVAL-BOX-ROWS FUN)))))))

;; if there are no args, avoid all contact
(DEFUN RUN-IT (THING)            ;for 0 args objects to be run
  (COND ((FUNCTIONP THING) (FUNCALL THING))
    ((DYNAMIC-CALL? THING)
     (WITH-DYNAMIC-VALUES-BOUND (MAKE-FRAME THING)
       (EVAL-BOX-ROWS THING)))
    (T                    ;must be a lexicall call (running a port)
     (WITH-STATIC-ROOT-BOUND (GET-LEXICAL-ROOT THING)
       (WITH-NEW-DYNAMIC-VALUES (MAKE-FRAME THING)
         (EVAL-BOX-ROWS THING))))))


;;;; Printing things

(DEFUN CONVERT-EVALUATOR-RETURNED-VALUE (THING)
  "Coerces any evaluator-only object into an object suitable for the editor. "
  (COND ((EVBOX? THING) (MAKE-BOX-FROM-EVBOX THING))
    ((EVPORT? THING) (MAKE-BOX-FROM-EVBOX THING))
    ((BOX? THING) (COPY-TOP-LEVEL-BOX THING))
    (T THING)))

(DEFUN PRINT-EVALUATOR-RETURNED-VALUE (E-THING)
  (LET ((THING (CONVERT-EVALUATOR-RETURNED-VALUE E-THING)))
    (COND ((NUMBERP THING) (MAKE-BOX `((,THING))))
      ((MEMQ THING *RETURNED-VALUES-NOT-TO-PRINT*) THING)
      ((SYMBOLP THING) (MAKE-BOX `((,(STRING THING)))))
      ((BOX? THING) THING)
      (T (FORMAT NIL "~A" THING)))))


(DEFUN EVAL-REGION (REGION)
  (WITH-COPYING-STATISTICS
    (LET ((RS (MAKE-BOXER-STREAM REGION)))
      (LOOP WITH RESULT = :NOPRINT
        FOR EXP = (PARSE-LIST-FOR-EVAL (BOXER-READ RS NIL))
        UNTIL (NULL EXP)
        DO (SETQ RESULT (EV-THING EXP NIL))
        FINALLY
          (RETURN (PRINT-EVALUATOR-RETURNED-VALUE RESULT))))))

(DEFUN EVAL-REGION-CATCHING-ERRORS (REGION)
  (IF *BOXER-ERROR-HANDLER-P*
      (CONDITION-CASE (ERROR)
      (EVAL-REGION REGION)
    (ERROR
     (tell error :report-string)))
      (EVAL-REGION REGION)))